perm filename LOOP.OLD[NEW,LCS]1 blob
sn#149690 filedate 1975-03-11 generic text, type T, neo UTF8
00100 TITLE LOOP ; SUBROUTINE LOOP(I,J,K,L,M,N)
00200 ENTRY LOOP,FINDIT,PLACE,DPYNEW,MVBEAM,MVBX
00300 EXTERNAL ACCPOG,DPYOUT,.COMM.,XRN,AMOD,PTR,KJY,DPY
00400 DEFINE FIXX(N)
00500 < JUMPGE N,.+5
00600 MOVNS N
00700 FIX N,233000
00800 MOVNS N
00900 CAIA
01000 FIX N,233000 > ; TO FIX IT LIKE 'IFIX' DOES.
01100 ; DIMENSION N(1)
01200 MM←1 ↔ NN←2 ↔ J←3
01300 LOOP: 0 ; DO 1 NN=I+L,J+L,K
01400 MOVE 1,@4(16)
01500 SUB 1,@3(16) ; MM IS IN 1
01600 MOVE 2,@(16)
01700 ADD 2,@3(16) ;I+L -- NN, 1ST TIME
01800 MOVE 3,@1(16)
01900 ADD 3,@3(16) ;J+L
02000 MOVE 4,@2(16) ;K
02100 MOVE 5,5(16) ; ADR. OF N
02200 ADDI 2,-1(5) ; N(NN)
02210 ADDI 3,-1(5)
02300 JUMPL 4,LP3 ; JUMP IF NEG. INCR.
02400 HRRM 1,.+1 ; ADD IN MM
02500 LP1: MOVE 6,(2)
02600 MOVEM 6,(2) ;N(NN)=N(NN+MM)
02700 CAIGE 2,(3)
02800 AOJA 2,LP1
02900 JRA 16,6(16)
03000 LP3: HRRM 1,.+2
03100 LP2: MOVE 6,(2) ;NEG. INCR.
03200 MOVEM 6,(2)
03300 CAILE 2,(3)
03350 SOJA 2,LP2
03400 JRA 16,6(16) ; END
03500
03600 PLACE: 0 ; FUNCTION PLACE(X)
03700 ; COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/XRN/RN(4000)
03800 ; EQUIVALENCE (R11,RJQ(9)),(RD,RN(4000))
03900 MOVN 2,@(16) ; PLACE=R11-ABS(RD-X)
04000 FADR 2,XRN+=3999 ;END
04100 MOVM 1,2
04200 MOVE 0,.COMM.+=12 ;R11
04300 FSBR 0,1
04400 JRA 16,1(16)
04500
04600 FINDIT: 0 ; FUNCTION FINDIT(N)
04700 SETZ ; COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
04800 HRRZ 1,@(16) ; COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
04900 HRRZI 2,PTR ; FINDIT=0
05000 ADDI 1,(2) ; L=PWDS(N)
05100 MOVE 2,-1(1) ; IF(RN(L+1).NE.1)GO TO 377
05200 FIXX(2) ; IF(RN(L+2).EQ.R2)RETURN
05220 MOVEM 2,PTR+=251 ; SENDS BACK A NUM IN L
05300 HRRZI 3,XRN ;377 FINDIT=-1
05400 ADDI 3,(2) ; END
05500 MOVE 5,(3) ; RN(L+1)
05600 CAME 5,[1.0]
05700 JRST FNEG
05800 MOVE 5,1(3) ;RN(L+2)
05900 CAME 5,.COMM.
06000 FNEG: SETO
06100 JRA 16,1(16)
06200
06300 DPYNEW: 0 ; SUBROUTINE DPYNEW
06400 JSA 16,ACCPOG ; COMMON/DPY/ST(4000),WDS(250),MEDIT,IGO
06500 JUMP [1] ; CALL ACCPOG(1)
06600 MOVE 2,DPY+=4251 ; IF(IGO.GT.0)RETURN
06700 JUMPG 2,DB ; CALL DPYOUT(1)
06800 JSA 16,DPYOUT ; END
06900 JUMP [1]
07000 DB: JRA 16,(16)
07100
07200 MVBEAM: 0 ;C THESE MOVE ENDS OF PARTIAL INNER BEAMS.
07300 MOVE 2,-1(16) ; SUBROUTINE MVBEAM(R,I,JY,L,W)
07400 ADD 2,@1(16) ;C L AND JY ARE FOR MOVES TO DIFF. STAFF.
07500 ADD 2,@2(16) ; DIMENSION R(1)
07600 MOVE 3,(3) ; Y=R(JY+I)
07700 MOVM 4,3 ; Z=ABS(Y)
07800 CAMGE 4,[=100.0] ; IF(Z.LT.100.)GO TO 1
07900 JRST MV1
08000 ;C NEXT FOR MINIS, DIAMONDS, 'X' NOTES. (LIMIT OF +-99 ON ALTITUDE.)
08100 JSA 16,AMOD ; Y=AMOD(Y,100.)
08200 JUMP 3
08300 JUMP [=100.0] ; 0 HAS Y
08400 MOVE 5,@4(16) ; X=Y+W
08500 FADR 5,0
08600 MOVM 6,5 ; Z=Z-ABS(Y)+ABS(X)
08700 MOVM 7,0 ;C PUTS ALL INTO POSITIVE
08800 FADR 4,7
08900 FSBR 4,6
09000 SKIPGE 5 ; IF(X)Z=-Z
09100 MOVNS 4 ; Z
09200 JRST MV2 ; GO TO 2
09300 MV1: FADR 3,@4(16) ;1 Z=Y+W
09400 MOVE 4,3 ; Z NOW IN 4
09500 MV2: HRRZ 3,@3(16) ;2 R(L+I)=Z
09600 ADD 3,@1(16)
09700 ADD 3,-1(16)
09800 MOVEM 4,(3) ; PUT IT IN R(L+I)
09900 JRA 16,5(16) ; END
10000
10100 MVBX: 0 ; SUBROUTINE MVBX(I)
10200 ; COMMON R2,JA,CENTR,J2,RJQ(20),L,RDIS,JQ(18)/KJY/K,JY/XRN/R(4000)
10300 MOVE 2,@(16) ; EQUIVALENCE (R4,RJQ(2)),(R8,RJQ(6))
10400 ADD 2,KJY+1 ; R(L+I)=R8+(R(JY+I)-R4)*RDIS
10500 MOVE 3,-1(2) ; R(JY+I)
10600 FSBR 3,.COMM.+5
10700 FMPR 3,.COMM.+=25 ; *RDIS
10800 FADR 3,.COMM.+=9 ; +R8
10900 MOVE 2,@(16)
11000 ADD 2,.COMM.+=24 ; + L
11100 MOVEM 3,-1(2) ;R(L+I)
11200 JRA 16,1(16)
11300 END